perm filename SLRSCL.F4[NEW,LCS]12 blob
sn#490155 filedate 1979-12-30 generic text, type T, neo UTF8
00100 C SUBRS. SLUR, (JUGGLE), (LOOP), (PLTSRT), (LINES), (HOMER),
00200 C SCL,(FORMAT), IBLANK, BMX, ACSHFT, SETUP, TYPE, SETLET, BEAMX
00300
00400 SUBROUTINE SLUR
00500 IMPLICIT INTEGER(A-Q,T-Z)
00600 COMMON/SLR/ SLURX(32)
00700 REAL CENTR
00800 COMMON /XRN/RN(1) /PLTR/PLT,RHT,RDIS
00900 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
01000 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
01100 1 J5,J6,J7,J8,J9,J10,J11,JQ(8),RJ
01200 COMMON/PTR/PWDS(1) /STF/RSTFAC(0/7),RSTJ2
01300 1 /LIMIT/LIMIT,ITEM,L,I,IX /ALF/INP,SLURY(72)
01400 CC DATA RSLUR/22.0/
01500 CF DATA RZZ/2.8/
01600 C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
01700
01800 CCC IF(JA.NE.12)GO TO 2
01900 CF RA=5.96*RSTJ2*R5
02000 CF L=3
02100 CF J8=J8*RDIS
02200 CF IF(J7.LE.J6)J7=J7+360
02300 CF KQ=6
02400 CF IF(PLT)KQ=1
02500 CF10 DO 3 K=J6,J7,KQ
02600 CF R=K
02700 CF CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
02800 CF3 L=2
02900 CF J8=J8-1
03000 CF IF(J8)RETURN
03100 CF RA=RA+1/RDIS
03200 CF L=3
03300 CF GO TO 10
03400 CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
03500 CCC CALL CIRCLE
03600 CCC RETURN
03700
03800 C*** SLURS *** 5, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
03900 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
04000 C P9=NUM IN BRACKET(IF NON-ZERO)
04100 2 J10=1
04200 J4=-1
04300 J5=1
04400 C ↑↑↑↑ FOR DPY ONLY (32 SEGS ARE USED)
04500 TWICE=-1
04600 IF(R3.GT.-1000)GO TO 2100
04700 R=-R3-1000
04800 L=R
04900 R=-(R3+1000+R)
05000 R3=RN(PWDS(L)+4)+R
05100 2100 IF(R6.GT.-1000)GO TO 21
05200 R=-R6-1000
05300 L=R
05400 R=-(R6+1000+R)
05500 R6=RN(PWDS(L)+4)+R
05600 COCT IF(R6)R6=202
05700 C R6=NEG. IS FOR PAGE-LAYOUT PROG. TELLS WHICH NOTE TO SLUR TO.
05800 21 RST7=RSTJ2*7.
05900 RJ=ABS(R7)
06000 C R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
06100 IF(RJ.LT.100)RJ=-1
06200 R7=AMOD(R7,100.0)
06300 IF(RJ.LT.300)GO TO 20
06400 RJ=0
06500 CC*** NOT YET! R5=R5-(2*R7)
06600 C R5 THINKS THE SLUR ISN'T REVERSED.
06700 C TO USE THIS ADD R6=SQRT((R5-R4)**2+(R6-R3)**2)+R3(WITH FACTORS)
06800 20 RQQ=R5-R4
06900 IF(R6.GT.1000)CALL RNOTE(R6)
07000 GO TO (5,6,7),J8+4
07100 GO TO 4
07200 CC5 R=32
07300 5 R=30
07400 C AFTER DOTTED NOTE
07500 GO TO 8
07600 6 R=22
07700 CC6 R=RSLUR
07800 C BETWEEN NOTES
07900 CC8 RX=-1.3
08000 8 RX=-0.75
08100 GO TO 9
08200 7 R=7
08300 RX=RSTJ2
08400 9 CALL RJBX(R)
08500 R6=R6+RX
08600 4 RXX=RHORZ(R6)-R3
08700 RTILT=RQQ*RST7
08800 80 RX=SQRT(RXX**2+RTILT**2)
08900 IF(J8.NE.-1)GO TO 1
09000 IF(RQQ.GT.8)RQQ=8
09100 IF(RQQ.LT.-8)RQQ=-8
09200 RQQ=RQQ*RSTFAC(J2)*1.0
09300 IF(R7)RQQ=-RQQ
09400 R3=R3-RQQ
09500 C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
09600 1 R=CENTR
09700 IF(J8.GT.0)GO TO 180
09800 C JUMP FOR BRACKETS
09900 L=32
10000 CALL SLOOP
10100
10200 CF RB=RX/71.
10300 CF DO 81 K=0,71
10400 CF81 SLURX(K+1)=RB*(K)+R3
10500 CF RA=R7*RST7
10600 CF41 IF(R9.EQ.0)R9=RZZ
10700 CF R=R+RA
10800 CF L=0
10900 CF DO 40 K=36,1,-1
11000 CF L=L+1
11100 CF RW=R-RA*(K/36.)**R9
11200 CF SLURY(L)=RW
11300 CF40 SLURY(73-L)=RW
11400 CF L=72
11500
11600 CF89 IF(RTILT.EQ.0)GO TO 87
11700 CF RW=ATAN2(RTILT,RXX)
11800 CF RA=SIN(RW)
11900 CF RB=COS(RW)
12000 CF RZ=SLURX(1)
12100 CF RW=SLURY(1)
12200 CF DO 83 K=1,L
12300 CF R=SLURX(K)-RZ
12400 CF RXX=SLURY(K)-RW
12500 CF SLURX(K)=RB*R-RA*RXX+RZ
12600 CF83 SLURY(K)=RB*RXX+RA*R+RW
12700
12800 87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
12900 J6=J10
13000 J7=L
13100 IF(J4.NE.0)GO TO 22
13200 CALL EXCH(J6,J7)
13300 J5=-1
13400
13500 22 IF(J11.NE.0)J11=3
13600 CALL SLRS
13700
13800 C22 IF(J11.EQ.0)GO TO 122
13900 CC IF(MOD(J11,2).EQ.0)J11=J11+1
14000 C MAKE SURE WE HAVE AN ODD NUMBER OF SEGMENTS FOR DASHES.
14100 C J11=3
14200 C KD=2
14300 C KT=0
14400 C KA=1
14500 C THIS WILL MAKE DASHED SLURS J11 HAS DASH SIZE.
14600 C DO 188 K=J6,J7,J5
14700 C KT=KT+1
14800 C IF(KT.LT.J11)GO TO 188
14900 C KT=0
15000 C KD=KD+KA
15100 C KA=-KA
15200 C BLANK-DASH FLIP-FLOP
15300 C188 CALL LINES(SLURX(K),SLURY(K),KD)
15400 C GO TO 123
15500
15600 C122 DO 88 K=J6,J7,J5
15700 C88 CALL LINES(SLURX(K),SLURY(K),2)
15800 123 IF(J5.GT.1)CALL LINES(SLURX(L),SLURY(L),2)
15900 C DISPLAY END POINT OF SLUR
16000 IF(TWICE)RETURN
16100 TWICE=TWICE-1
16200 GO TO 182
16300 180 RW=R+R7*RST7
16400 TWICE=-1
16500 CC KQ=1
16600 J5=1
16700 RX=RX+R3
16800 CC RA=(R5-R4)*RST7
16900 IF(J9.EQ.0)GO TO 181
17000 RZ=RTILT/(RX-R3)
17100 TWICE=2
17200 CC RZ=RX-R3
17300 RXX=RX
17400 RWID=(R3+RXX)/2.
17500 182 IF(TWICE.EQ.1)GO TO 183
17600 C DOES LEFT SIDE FIRST.
17700 IF(TWICE.EQ.0)GO TO 184
17800 C LAST IS NUMBER.
17900 J8=2
18000 RC=RSTJ2*13.
18100 RX=RWID-RC
18200 RWW=RTILT
18300 185 RTILT=RZ*(RX-R3)
18400
18500 C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
18600
18700 GO TO 181
18800 183 J8=3
18900 RX=RXX
19000 RTILT=RWW
19100 RXX=R3
19200 R3=RWID+RC
19300 RXX=RZ*(R3-RXX)
19400 R=R+RXX
19500 RW=RW+RXX
19600 GO TO 185
19700
19800 181 SLURX(1)=R3
19900 SLURY(1)=R
20000 SLURX(2)=R3
20100 SLURY(2)=RW
20200 SLURX(3)=RX
20300 SLURY(3)=RW+RTILT
20400 SLURX(4)=RX
20500 SLURY(4)=R+RTILT
20600 L=4
20700 IF(J8.EQ.2)L=3
20800 IF(J8.EQ.3)J10=2
20900 CC TWICE=-1
21000 GO TO 87
21100 184 J3=RWID
21200 C PUT IN VERT. POS. WHEN SLOPE!
21300 R4=RQQ/2.+R4+R7-1.
21400 R6=0.875
21500 C SIZE(R6) IS 0.875 R7=1 IS FOR ITALICS
21600 R7=1
21700 R8=0
21800 CALL MAKNUM(R9)
21900 END
22000
22100 SUBROUTINE SCL
22200 C SETS UP SCALING MARKERS.
22300 COMMON /STF/RSTFAC(0/7),RSTJ2 /RINP/SU(900)
22400 COMMON R2,JA,CT,J2,R3,R4,R5,RJQ(17),J3,J4,J5,J6,J(16)
22500 1 /POSI/STFF(0/7),J102,POS
22600 J2=R2
22700 IF(J2.NE.99)GO TO 1008
22800 CALL HYDPOG(2)
22900 RETURN
23000 1008 J5=0
23100 J6=0
23200 RSTJ2=RSTFAC(J2)
23300 C SETS UP SCALE LINES.
23400 J4=200
23500 IF(R3.NE.0)J4=400
23600 C PUTS SCALE TO 400
23700 R2=STFF(J2)+60.*RSTJ2
23800 RJ=R2+60.
23900 CALL DPYSET(2,SU,700)
24000 CALL DPYBRT(1)
24100 POS=RJ+40.
24200 RSTJ2=1.
24300 DO 1002 MX=10,J4,10
24400 RA=RHORZ(FLOAT(MX))
24500 R3=RA-58
24600 IF(MX.GT.10)CALL PNUM
24700 CC1005 IF(R5.NE.0)GO TO 1007
24800 C JUMP FOR STAFF NUMBERS
24900 CALL LINX(RA,R2,RA,RJ)
25000 J5=J5+1
25100 1002 IF(J5.EQ.10)J5=0
25200 CALL LINES(-596.0,RJ,2)
25300 CALL LINES(-596.0,R2,2)
25400 R6=1.5
25500 C NEXT SETS UP STAFF NUMBERS TO FAR RIGHT(OUT OF WAY OF TYPING.)
25600 R3=615.
25700 DO 1007 K=0,7
25800 POS=STFF(K)+40.
25900 J5=IABS(K)
26000 CALL PNUM
26100 1007 CONTINUE
26200 CC CALL DPYDO(2)
26300 CALL DPYOUT(2)
26400 CALL SETPOG(1)
26500 END
26600
26700 FUNCTION IBLANK(IS,N)
26800 COMMON /XRN/RN(2000)
26900 IBLANK=0
27000 IF(AMOD(RN(IS+N),100.0).EQ.99.0)IBLANK=-1
27100 END
27200
27300 SUBROUTINE BMX(RA)
27400 C RA=NUMB. OF TAILS
27500 C VQ HOLDS TEMPORARY INFO RE. MULTIPLE BEAMS.
27600 COMMON E,F,G,H,RJQ(34),RB,VQX,JB,B,JV,JW /XRN/RN(1)
27700 1 /RINP/R(10,85),VQ(100) /STF/RSTFAC(0/7),RSTJ2
27800 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND /RNW/RNW
27900 1/LIMIT/LIMIT,ITEM,LL,IS,IX /SC/J,L,MK
28000 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,IQT
28100 1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
28200 1 /SCX/JALPHA(30),JX,U,JZ,IRHY,JD,KA,KB,IZ
28300 M=IS-12
28400 RX7=RN(7+M)
28500 C ORIGINAL STEM DIR. AND NUM. OF BEAMS INFO.
28600 DO 1 L=KN,K
28700 B=R(7,L)
28800 JB=B/10
28900 B=B-JB*10
29000 C??? B=AMOD(R(7,L),10.0)
29100 IF(R(8,L).EQ.1000.)B=0
29200 C AVOIDS GRACE NOTES AND NON-NOTES
29300 IF(R(1,L).NE.1)B=0
29400 1 VQ(L)=B
29500 VQ(K+1)=0
29600 C CLEARS IT FOR ROUTINE AT '3'
29700 JB=KN
29800 RX8=0
29900 JBX=0
30000 C THE ABOVE 2 ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
30100
30200 6 DIS=0
30300 RB9=0
30400 DO 2 L=JB,K
30500 IF(VQ(L).LE.RA)GO TO 2
30600 C SKIP IF EQ. TO PRESENT BEAM
30700 RB=VQ(L)
30800 4 DO 11 JD=L,K
30900 VQX = VQ(JD)
31000 IF(VQX.GE.RB)GO TO 20
31100 IF(VQX.EQ.0)GO TO 11
31200 C VQX=0 ON NON-STEM NOTES OF CHORDS. (HENCE NO TAILS)
31300 21 B=10.
31400 IF(L.GT.KN)GO TO 13
31500 GO TO 16
31600 20 JV=JD
31700 IF(VQX.GT.RB)GO TO 21
31800 11 JW=JD
31900 B=20
32000 C FINDS NEED FOR BEAM TO LEFT
32100 16 B=B+RA
32200 IF(JBX)GO TO 50
32300 C FOR NEW COMPOSITE BEAM FEATURE 5/78
32400 JE=RN(7+M)/10.
32500 RN(7+M)=JE*10.+RA
32600 CCC RN(7+M)=RN(7+M)+RB-RA
32700 GO TO 51
32800 50 DO 5 JE=1,6
32900 5 RN(JE+IS)=RN(JE+M)
33000 RN(7+IS)=RX7+RB-RA*2.
33100 C ADDS RIGHT NUM. OF BEAMS
33200 51 IF(L.NE.JV)GO TO 10
33300 IF(L.EQ.KN)GO TO 377
33400 IF(L.NE.K)GO TO 10
33500 377 B=-B
33600 C PARTIAL, UNATTACHED BEAM IS PLACED AUTOMATICALLY IN ITMSUB.
33700 GO TO 8
33800 13 IF(JV.GT.L)GO TO 14
33900 IF(R(7,L+1).LT.10)GO TO 15
34000 C NEXT FOR DOT ON FOLLOWING NOTE.
34100 DIS=10.
34200 GO TO 19
34300 15 DIS=20.
34400 C SHORT INNER BEAM TO LEFT OF STEM
34500 19 B=-RA
34600 GO TO 16
34700 14 DIS=30
34800 C LONG INNER BEAM
34900 JV=-JV
35000 GO TO 16
35100
35200 C PARTIAL BEAM IS ON RIGHT(+) OR LEFT(-). RBM IS LENGTH.
35300 10 IF(L.EQ.KN)GO TO 22
35400 IF(JV.GE.0)GO TO 17
35500 B=R(3,L)
35600 JV=-JV
35700 L=JV
35800 22 IF(VQ(JW+1).GT.VQ(JW))GO TO 17
35900 VQ(JW)=VQ(JW+1)
36000 JW=JW-1
36100 17 IF(L.NE.JB)GO TO 18
36200 IF(B.LT.20.)L=JV
36300 C PUTS BEAMS IN RIGHT PLACE.
36400 18 RC=R(10,L)
36500 IF(RC.EQ.0)GO TO 23
36600 RB=RNW*RSTJ2
36700 IF(ABS(R(4,L)).GE.100)RB=RB*.6
36800 C GET WIDTH OF NOTE(RNW) FOR DISPLACEMENT
36900 CC18 RB9=R(3,L)
37000 IF(RC.EQ.2)RB=-RB
37100 RC=RB
37200 CCC B=B+RC
37300 23 RB9=RC+R(3,L)
37400 C THIS WILL BE POS.3
37500 DIS=RA+DIS
37600 C DISPLACES
37700 GO TO 8
37800 2 CONTINUE
37900 RETURN
38000 8 JB=JW+1
38100 C FINDS SIDE (L,R) FOR PARTIAL BEAM
38200 C FOR NEW DISPLACEMENT
38300 RN(IS+11)=-1
38400 IF(RB9+DIS.EQ.0)GO TO 31
38500 IF(DIS.LT.10)GO TO 32
38600 IF(DIS.LT.30)GO TO 33
38700 C INNER PARTIAL BEAM IS NEXT
38800 DIS=DIS-30
38900 GO TO 31
39000 32 IF(B.GE.20)GO TO 12
39100 DIS=B-10
39200 B=-1
39300 C -1 PICKS UP POS OF P3
39400 CC B=RN(3+M)
39500 GO TO 31
39600 12 DIS=B-20
39700 B=RB9
39800 RB9=-1
39900 C -1 IN P9 WILL PICK UP POS OF P6
40000 CC RB9=RN(6+M)
40100 C INNER BEAM ATTACHED TO LFT SIDE.
40200 GO TO 31
40300 33 B=-DIS
40400 DIS=0
40500 31 L=IS
40600 IF(JBX)GO TO 53
40700 L=M
40800 DIS=(RB-RA)*100.+1.
40900 CCC DIS=RA*100+1
41000 53 IF(RX8.GT.1.)GO TO 52
41100 IF(RB9.NE.0)GO TO 52
41200 IF(RX8.NE.0)GO TO 54
41300 CC B=B+10
41400 CC IF(B.GT.-10.)B=0
41500 CC IF(B.EQ.0)B=-20
41600 RX8=B
41700 GO TO 52
41800 54 RN(8+M)=-30
41900 C TWO UNATTACHED BEAMS, LEFT AND RIGHT
42000 RX8=1
42100 GO TO 55
42200 52 RN(8+L)=B
42300 RN(9+L)=RB9
42400 RN(10+L)=DIS
42500 IF(JBX)CALL UPDATE(9)
42600 C ADDED ANOTHER ITEM (PART. BEAM)
42700 JBX=-1
42800 JA=0
42900 55 IF(JB.LE.K)GO TO 6
43000 END
43100
43200 SUBROUTINE ACSHFT(RX)
43300 COMMON /XRN/RN(1) /STF/RSTFAC(0/7),RSTJ2
43400 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
43500 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
43600 1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
43700 1 /RINP/R(10,85),VQ(100)
43800 EQUIVALENCE (A,F(1)),(B,F(2)),(X,F(4)),
43900 1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
44000 Z=0
44100 L=K-1
44200 M=L-ABS(RX)
44300 JD=1
44400 RN1=99
44500 Y=-.23
44600 IF(RX.LT.0)GO TO 1
44700 L=M
44800 M=K-1
44900 JD=-1
45000 1 DO 2 N=M,L,JD
45100 C DOES IT HAVE AN ACCID?
45200 IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
45300 A=0
45400 B=0
45500 IF(N.LT.L)A=R(6,N+1)
45600 IF(N.GT.M)B=R(6,N-1)
45700 IF(RN1.NE.99)GO TO 3
45800 C IS THIS THE FIRST ACCID?
45900 RN1=R(4,N)
46000 GO TO 6
46100 3 RH=R(4,N)
46200 IF(ABS(RH-RN1).LT.5)GO TO 4
46300 RN1=RH
46400 IF(Y.GT.0)Z=Z+.04
46500 C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
46600 Y=-.23+Z
46700 6 IF(A.EQ.20)GO TO 477
46800 IF(B.NE.20)GO TO 4
46900 477 Y=Z
47000 4 X=0
47100 IF(R(6,N).EQ.20)X=-.24
47200 IF(R(6,N).EQ.10)X=.24
47300 Y=Y+.23
47400 IF(X+Y.LT.1)GO TO 7
47500 RN1=RH
47600 Z=Z+.04
47700 Y=0
47800 IF(A.EQ.20)GO TO 677
47900 IF(B.NE.20)GO TO 577
48000 677 Y=.23
48100 C SO Y DOESN'T GET >1.
48200 577 Y=Y+Z
48300 7 X=X+Y
48400 IF(ABS(X-.04).LT..01)X=0
48500 IF(X.GE.0)GO TO 5
48600 Y=.23+Z
48700 X=Z
48800 5 R(5,N)=R(5,N)+X*RSTFAC(IFIX(STAFF))
48900 C SPACING OF ACCI. DEPENDS ON STAFF SIZE FACTOR AT THIS POINT
49000 2 CONTINUE
49100 END
49200
49300 C SETUP ALLOWS SETING UP RHYTHMS ON DESIGNATED STAFF FOR SPACING ALL OTHERS.
49400 SUBROUTINE SETUP
49500 INTEGER PWDS
49600 CC COMMON /ALF/JX,X,RD,RNL,RN6,M,A,RB,RC,
49700 CC 1 INP(64) /SCM/V(78),IV,LCNT,STAFF,LIST(200),REND
49800 COMMON /SCM/V(78),IV,LCNT,STAFF,LIST(200),REND
49900 1 /PTR/PWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX
50000 1 /DPY/ST(4000),MEDIT,GO /XRN/RN(1)
50100 1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,
50200 1 ENDP,RA,RDD,ITB,POSB
50300 DIMENSION RPOS(2,100)
50400 EQUIVALENCE (RPOS,ST(3400))
50500
50600 C RHYTHMIC VALUES ARE SAVED IN P9 OF NOTES AND P7 OF RESTS.
50700 STUP=-1
50800 C THIS SENDS INFO TO SUBR. NOTES
50900 IF(SET4.GT.7)RETURN
51000 C **** BE SURE SETUP STAFF HAS SPACE VALUES IN NOTES AND RESTS!!!
51100 IF(ITEM.EQ.0)RETURN
51200 JX=0
51300 CC RNL=0
51400 RA=0
51500 DO 9534 K=1,ITEM
51600 L=PWDS(K)
51700 IF(RN(L+2).NE.SET4)GO TO 9534
51800 RD=RN(L+1)
51900 IF(RD.LT.5)GO TO 5
52000 IF(RD.LT.17)GO TO 9534
52100 5 IF(RD.GT.2)GO TO 6
52200 RC=7
52300 IF(RD.EQ.2)RC=5
52400 IF(RN(L).LT.RC)GO TO 9534
52500 M=9
52600 IF(RD.EQ.2)M=7
52700 RC=RN(L+M)
52800 IF(RC.EQ.0)GO TO 9534
52900 C FOR OTHER NOTES ON SPACING STAFF.
53000 IF(RC.EQ.4./88.)GO TO 9534
53100 C THESE FOR GRACE NOTES (1/88 NOTES)
53200 CC IF(RN(L+8).GT.999.)GO TO 9534
53300 C SKIPS MINI-NOTES. BUT TROUBLE IF STEMS CAUSE P8 TO BE ≤ 999.
53400 GO TO 7
53500 C SKIPS 'OTHER' CHORD TONES (I.E. P9=0 IN A NOTE)
53600 6 IF(RD.NE.3)GO TO 8
53700 IF(RN(L).LT.3)GO TO 7
53800 RC=RN(L+5)
53900 IF(RC.GE.100)GO TO 7
54000 IF(RC.GT.3)GO TO 9534
54100 C SKIPS IF NOT A REAL CLEF (+100=MINI CLEF)
54200 GO TO 7
54300 8 IF(RD.NE.4)GO TO 10
54400 IF(RN(L).GT.2)GO TO 9534
54500 C SKIPS IF NOT BARLINE (I.E. ONLY 4 PARAMS)
54600 10 IF(RD.NE.2)GO TO 7
54700 IF(RN(L).LT.5)GO TO 9534
54800 IF(RN(L+7).EQ.0)GO TO 9534
54900 7 JX=JX+1
55000 RPOS(1,JX)=RN(L+3)
55100 IF(RD.GT.2)GO TO 3
55200 C JUMP WHEN TIME VALUES ARE IN P8
55300 CC RC=RN(L+M)
55400 C FOR VALUES AUTOMATICALLY SET. ALLOWS NON-DUPLE UNITS IN SETUP
55500 277 RA=RA+RC
55600 C SUM OF RHYTHS
55700 GO TO 77
55800 3 RC=-RD
55900 77 RPOS(2,JX)=RC
56000 C RC IS RHYTHMIC VALUE OF NOTE.
56100 9534 CONTINUE
56200 C NEXT PUTS ITEMS IN PROPER ORDER IF THEY WEREN'T ALREADY
56300 C*** 2ND NOTE OF DBL STOP CAN'T!! HAVE RHYTH. VALUE *******
56400 IF(RA.EQ.0)RETURN
56500 C RA=0 MEANS DIDN'T FIND RHYTHMS ON SPACING STAFF.
56600
56700 CALL SORT2(RPOS,JX)
56800 ENDP=200.
56900 IF(RPOS(2,JX))ENDP=RPOS(1,JX)
57000 DO 1 L=1,JX
57100 1 IF(RPOS(2,L).GT.0)GO TO 4
57200 4 RD=RPOS(1,L)
57300 RB=ENDP-RD
57400 C TOTAL SPACE FROM 1ST NOTE TO END OF LINE
57500 RC=RPOS(2,L)
57600 RPOS(2,L)=RD
57700 C REAL AND AVERAGED POSITIONS OF 1ST NOTE ARE THE SAME.
57800 DO 2 K=L+1,JX
57900 RE=RPOS(2,K)
58000 IF(RE)GO TO 2
58100 RD=RC/RA*RB+RD
58200 RC=RE
58300 RPOS(2,K)=RD
58400 2 CONTINUE
58500 C 1,K=REAL POS. 2,K=AVERAGED POS.
58600 C IN RHYTH: POS=(P1-AVG2)*(RL2-RL1)/(AVG2-AVG1)+RL1
58700 JX=JX+1
58800 RPOS(1,JX)=ENDP
58900 RPOS(2,JX)=ENDP
59000 STUP=0
59100 C THIS FOR NOTES AND RHYTH
59200 END
59300
59400 SUBROUTINE TYPE
59500 CC COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
59600 CC DATA LEL/'L'/,LR/'R'/,LU/'U'/,LD/'D'/,LE/'E'/,KSLA/'/'/
59700 CC 1,LC/'C'/,LS/'S'/,LF/'F'/,LA/'A'/,LI/'I'/,LW/'W'/
59800 CML COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
59900 COMMON/ALF/INP(72),ML /IDEV/IDEV /MKX/KSLA,ISEMI,LESS,IGT
60000 IF(IDEV.NE.5)GO TO 2
60100 1 CALL TYPSTR('TYPE --')
60200 CALL TYPCRLF
60300 CCC TYPE 8005
60400 2 READ(IDEV,2114,END=167)INP
60500 IF(INP(1).EQ.LESS)GO TO 167
60600 IF(INP(1).NE.IGT)RETURN
60700 IDEV=1
60800 GO TO 2
60900 167 IDEV=5
61000 GO TO 1
61100 CC ACCEPT 2114,INP
61200 2114 FORMAT(72A1)
61300 CCC8005 FORMAT(' TYPE --'/)
61400 CC** IF(JA.NE.16)CALL LNEND
61500 C FOR 'SCORE' INPUT
61600 END
61700
61800 SUBROUTINE SETLET
61900 COMMON/SCM/V(76),RR4,NN,Y,LCNT,STAFF,JLIST(200),REND
62000 C NOTE DIFFERENCE IN V ARRAY LNGTH 76+RR4+NN
62100 COMMON /MKX/KSLA,ISEMI,LESS,IGT
62200 COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,JR
62300 1 /PTR/PWDS(1) /IDEV/IDEV
62400 CCC 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(2000)
62500 COMMON/FRMT/F78F(1),FA1(1),FA5(1),KK /ALF/INP(72),ML
62600 COMMON/SCN/LEL,LR,LU,LD,SLA,LE,LC,LS,LF,LA,LI,LW
62700 1 /POSI/STFP(0/7),J102,POS /LIMIT/LIMIT,ITEM,L,I,IX /XRN/RN(1)
62800 1 /RINP/RPOS(2,450) /DPY/ST(4000),MEDIT,IGO
62900 DIMENSION SU(320)
63000 EQUIVALENCE (J5,JQ(3)),(ISET,RJQ(9)),(SU(1),ST(3600))
63100 CCC DATA DISP/0.0/
63200 KK=L
63300 C L=NUMBER OF ITEMS TYPED +1
63400 M=1
63500 IF(R4.EQ.0)KK=0
63600 C =0 ALWAYS WANTS PAIRS OF NUMS.
63700 RR4=R4
63800 C GIVEN VERTICAL POS.
63900 R4=20
64000 RPOS(1,1)=0
64100 DO 1 K=1,ITEM
64200 IF(FINDIT(K))GO TO 1
64300 C SKIPS NON-NOTES AND WRONG STAFF
64400 M=M+1
64500 RPOS(1,M)=RN(L+3)
64600 1 CONTINUE
64700 IF(M.EQ.1)RETURN
64800 C M=1 MEANS NO NOTES ON THIS LINE
64900 CALL DPYSET(3,SU,320)
65000 CALL DPYBRT(6)
65100 CC R6=1
65200 POS=STFP(J2)
65300 J5=1
65400 CALL SORT2(RPOS,M)
65500 K=2
65600 22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
65700 C ROUNDS OFF POSITION TO 2 DECI. PLACES
65800 M=M-1
65900 DO 20 J=K,M
66000 20 RPOS(1,J)=RPOS(1,J+1)
66100 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
66200 IF(M.LT.K)K=M
66300 GO TO 22
66400 CCC302 FORMAT(17X'POS. FOR -- ',72A1/)
66500 2 K=K+1
66600 IF(K.LT.M)GO TO 22
66700 DO 4 K=2,M
66800 R3=RHORZ(RPOS(1,K))
66900 CALL PNUM
67000 J5=J5+1
67100 4 IF(J5.EQ.10)J5=0
67200 CALL DPYOUT(3)
67300 CC CALL DPYDO(3)
67400 CALL SETPOG(1)
67500 RPOS(1,M+1)=200
67600 NN2=1
67700 J=1
67800 JJ=1
68700 C FLAG FOR ALL BLANKS AT END OF LINE
68800 30 MM=-1
68900 K=JJ
69000 300 IF(INP(K).NE.' ')MM=0
69100 IF(INP(K).EQ.KSLA)GO TO 301
69200 IF(K.EQ.72)GO TO 301
69300 K=K+1
69400 GO TO 300
69500 167 IDEV=5
69600 301 IF(MM)GO TO 31
69650 IF(IDEV.EQ.1)GO TO 1301
69700 CALL TYPSTR(' POS. FOR -- ')
69900 DO 302 LL=JJ,K
70000 302 CALL TYPCHR(INP(LL),1)
70200 CALL TYPSTR(' ')
70400 1301 NN=NN2
70500 NN2=NN2+1
70600 READ(IDEV,F78F,END=167)V(NN),V(NN2)
70700 REREAD FA1,JJ
70800 IF(JJ.EQ.LESS)GO TO 167
70900 IF(JJ.NE.IGT)GO TO 267
71000 IDEV=1
71100 GO TO 302
71200 CQQ ACCEPT F78F,V(NN),V(NN2)
71300 CC IF(RR4.EQ.0)NN2=NN2+1
71400 CC V(NN2)=0
71500 267 IF(RR4.NE.0.AND.V(NN2).EQ.0)V(NN2)=RR4
71600 NN2=NN2+1
71700 V(NN2)=0
71800 JJ=K+1
71900 IF(K.LT.72)GO TO 30
72000
72100 31 X=V(J)+1
72200 DO 32 K=NN,1,-1
72300 32 IF(V(K).NE.0)GO TO 320
72400 320 IF(K.GT.KK)KK=-1
72500 C NOW PAIRS OF NUMS WILL SET INDIV. VERT. POS.; SINGLE DON'T
72600 3 K=X
72700 A=RPOS(1,K)
72800 B=RPOS(1,K+1)
72900 RN(ISET+3)=A+(B-A)*(X-K)
73000 CCC RN(ISET+3)=A+(B-A)*(X-K)+DISP
73100 C DISP IS DISPLACEMENT OF CURRENT LETTERS.
73200 IF(KK.GT.0)GO TO 5
73300 C NEXT FOR PAIRS OF NUMS.
73400 RN(ISET+4)=V(J+1)
73500 J=J+2
73600 GO TO 6
73700 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
73800 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
73900 5 J=J+1
74000 6 ISET=ISET+RN(ISET)+3
74100 IF(ISET.GE.I)GO TO 7
74200 IF(RN(ISET).EQ.8)GO TO 6
74300 C =8 MEANS MORE LETTERS TO COME.
74400 X=V(J)+1
74500 IF(X.GT.1)GO TO 3
74600 C CAN'T PUT LETTER AT POS. 0 *********
74700 7 K=ITEM+1
74750 IF(IDEV.EQ.1)RETURN
74800 CALL TYPSTR('FIRST ITEM WAS ')
74900 CALL TYPINT(K)
75000 CALL TYPCRLF
75300 END
75400
75500 SUBROUTINE BEAMX
75600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RRJJ/RJJ2,RJJ(20)
75700 1 /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
75800 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
75900 1 (R6,RJQ(4)),(J10,JQ(8)),(J6,JQ(4)),(R4,RJQ(2)),(R7,RJQ(5))
76000 1,(R3,RJQ(1)),(J8,JQ(6)),(J7,JQ(5))
76100 1,(R11,RJQ(9)),(R10,RJQ(8)),(R8,RJQ(6)),(RJ3,RJJ(1))
76200 1,(R9,RJQ(7)),(J9,JQ(7))
76300
76400 IF(J10.GE.100)GO TO 6
76500 CALL BMSTF
76600 RETURN
76700 6 JZ=-2
76800 JX8=R8
76900 IF(JX8.GE.-1)GO TO 16
77000 JX8=R8/10.0
77100 JX8=JX8*10
77200 C MAKE SURE LAST DIGIT IS ZERO
77300 R8=JX8
77400 16 RR8=R8
77500 R8=0
77600 RR9=R9
77700 R9=0
77800 CC RR10=R10
77900 RR6=R6
78000 RR3=R3
78100 RR4=R4
78200 RR5=R5
78300 RSTJ=RSTJ2
78400 J=10*(J7/10)
78500 C J=STEM DIR. (10 OR 20)
78600 JJ=J10/100
78700 JJ10=J10-JJ*100
78800 C IF 3RD DIGIT OF P10 = 0, THEN TWO SECONDARY BEAM GROUPS ARE MADE.
78900 C THEN P8 AND P9 ARE THE LIMITS OF THE GAP BETWEEN THE SECONDARY GROUPS.
79000
79100 C IF 3RD DIGIT OF P10 = 1, THEN SINGLE SECONDARY BEAM GROUP IS MADE.
79200 C THEN P8 AND P9 ARE THE OUTER LIMITS OF THE SECONDARY GROUP
79300 CCC JJ7=J7-JJ
79400 CCC J7=J+JJ
79500 JJ7=J7-J
79600 C J7=NUM. OF FULL BEAMS (1ST DIGIT OF P10=NUM OF ADDED BEAMS)
79700 7 J10=0
79800 5 J8=R8
79900 J9=R9
80000 R7=J7
80100 R10=J10
80200 CALL BMSTF
80300 JZ=JZ+1
80400 IF(JZ)1,2,3
80500 3 RETURN
80600
80700 1 IF(RR8.GE.0)GO TO 8
80800 IF(JX8.GE.-20)GO TO 11
80900 C UNATTACHED PARTIAL BEAM:
81000 C P8= -10=ON LEFT, -20=RIGHT, -30=BOTH
81100 RR8=RR8+10
81200 IF(JX8.EQ.-31)GO TO 11
81300 JX8=JX8-1
81400 RR9=0
81500 C ↑↑↑ A PRECAUTION
81600 JZ=JZ-2
81700 11 R8=RR8-AMOD(R7,10.0)
81800 CC J7=J+JJ
81900 10 R9=RR9
82000 JZ=JZ+1
82100 GO TO 4
82200 8 IF(JJ10.EQ.0)GO TO 9
82300 C NEXT MAKES ONE SECONDARY BEAM GROUP.
82400 R8=RR8
82500 GO TO 10
82600 9 R8=-1
82700 R9=RR8
82800 4 J7=J+JJ
82900 CCC4 J7=JJ7
83000 R6=RR6
83100 R3=RR3
83200 J3=RR3
83300 R4=RR4
83400 R5=RR5
83500 J10=JJ7
83600 CCC J10=JJ
83700 C J10 IS DISPLACEMENT FOR OTHER BEAMS
83800 RSTJ2=RSTJ
83900 GO TO 5
84000 2 R8=RR9
84100 R9=-1
84200 GO TO 4
84300 END